home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb13.arc / UTIL.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-19  |  58KB  |  1,658 lines

  1.  
  2. {****************************************************************************
  3.  *  This Module Comprises the various utility routines used by the other    *
  4.  * modules in the program.  Routines included in this module are:           *
  5.  *                                                                          *
  6.  *         Routine                   Use                                    *
  7.  *  *  1   Upper_Left_X      Returns the left x coordinate of active window *
  8.  *  *  2   Upper_Left_Y      Returns the upper y coord of active window     *
  9.  *  *  3   Lower_Right_X     Returns the right x coord of active window     *
  10.  *  *  4   Lower_Right_Y     Returns the lower y coord of active window     *
  11.  *  *  5   RvsOn             Turns on Reverse Video                         *
  12.  *  *  6   RvsOff            Turns off Reverse Video                        *
  13.  *     7   Yes               Prints a prompt, if user inputs 'Y' returns    *
  14.  *                           Trues, otherwise returns False                 *
  15.  *  *  8   Click             Produces a single click from the PC speaker    *
  16.  *  *  9   Alert             Prints a message to the screen and makes noise *
  17.  *  * 10   Beep              Makes noise for a specified period of time     *
  18.  *    11   Replicate         Duplicates a character a specified no. of times*
  19.  *    12   Left              Left justifys a string in a field of spaces    *
  20.  *    13   Center            Centers a string in a field of specified width *
  21.  *    14   Get_Payment_Amount Calculates a loan payment amount              *
  22.  *    15   Write_Neatly      Outputs numbers with commas                    *
  23.  *    16   Get_Str           Writes a string to the screen, allows it to be *
  24.  *                           edited and returns the terminating character   *
  25.  *    17   Get_Num           Does for numbers what Get_Str does for strings *
  26.  *  * 18   Frame             Frames a specified portion of the screen       *
  27.  *  * 19   UnFrame           Removes the frame from the screen              *
  28.  *  * 20   Menu              Displays a menu and gets a user input          *
  29.  *  * 21   Clear_Window      Clears the screen within a window              *
  30.  *  * 22   Window_Frame      Sets up, frames and titles a screen window     *
  31.  *    23   Encrypt           Encrypts a string using XOR                    *
  32.  *    24   Decrypt           Decrypts a string encrypted by encrypt         *
  33.  *    25   GetChar           Gets a character from the keyboard             *
  34.  *    26   Wait              Waits for a KeyPressed                         *
  35.  *    27   Get_Pass          Gets a password from the user                  *
  36.  *  * 28   Push_Screen       Saves the current screen                       *
  37.  *  * 29   Pop_Screen        Restores a saved screen                        *
  38.  *    30   Inc               Increments an integer by 1                     *
  39.  *    31   Dec               Decrements an integer by 1                     *
  40.  *  * 32   Setup             Sets the IBM Serial Interface                  *
  41.  *    34   Upper             Convert String to Upper Case                   *
  42.  *    35   Lower             Convert String to Lower Case                   *
  43.  *  * 36   DosConOut         Usr Device Driver.  Calls DOS Video Output     *
  44.  *  * 37   SerialIn          Aux Device Driver.  Serial port input          *
  45.  *  * 38   SerialOut         Aux Device Driver.  Serial port output         *
  46.  *    39   Power             Raises a number to a power                     *
  47.  *  * 40   Data              Returns true if there is data at the RS232     *
  48.  *  * 41   ColScr            Switch to color monitor if there               *
  49.  *  * 42   MonoScr           Switch to Monochrome monitor if there          *
  50.  *  * 43   Marquee           Display Marquee and put message in it          *
  51.  *  * 44   Help              Displays an appropriate help screen            *
  52.  *  * 45   Well              Expresses impatience                           *
  53.  *  * 47   Siren             makes a sound like a siren                     *
  54.  *  * 48   GetForm           generalized input routine                      *
  55.  *  * 49   Date              gets the date from the system                  *
  56.  *  * 50   Time              gets time from system                          *
  57.  *  * 51   Push_Window       pushes a small section of the screen           *
  58.  *  * 52   Elapsed_time      the time in seconds from the argument          *
  59.  *                                                                          *
  60.  *  * Indicates that the routine has IBM PC specific sections and would need*
  61.  *    to be modified for other computers                                    *
  62.  ****************************************************************************}
  63.  
  64. Procedure HighVideo;
  65.  
  66. Begin
  67.   TextColor(White);
  68.   TextBackground(Black);
  69. End;
  70.  
  71. Procedure NormVideo;
  72.  
  73. Begin
  74.   TextColor(White);
  75.   TextBackground(Black);
  76. End;
  77.  
  78. Procedure LowVideo;
  79.  
  80. Begin
  81.   TextColor(LightGray);
  82.   TextBackground(Black);
  83. End;
  84.  
  85. Type
  86.   Parity_Types = (Odd_Parity, Even_Parity, No_Parity);
  87.   Reg          = Record
  88.     AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
  89.   End;
  90.  
  91. Const
  92.   COM1  =  1016;  {Com1 and Com2 Base port address}
  93.   DLL   =   0;    {LSB of Divisor Latch, Offset 0, R/W}
  94.   DLM   =   1;    {MSB of Divisor Latch, Offset 1, R/W}
  95.   LCR   =   3;    {Line Control Register, Offset 3, R/W}
  96.   MCR   =   4;    {Modem Control Register, Offset 4, R/W}
  97.   LSR   =   5;    {Line Status Register, Offset 5, RO}
  98.   MSR   =   6;    {Modem Status Register, Offset 6, RO}
  99.   MRR   =   7;    {Modem Rate Register, Offset 7, RO, (1200B Hayes only)}
  100.   DLAB  =   128;  {Data Latch Access Bit, High to access DLL and DLM}
  101.   SBRK  =   64;   {Set Break, High to transmit a break signal}
  102.   STPTY =   32;   {Stick Parity, If high parity bit follows EPS}
  103.   EPS   =   16;   {Select Even Parity, High for Even parity}
  104.   PEN   =   8;    {Parity Enable, High to enable parity checking}
  105.   STB   =   4;    {Stop Bits, High for 2 stop bits (1.5 for 5 bit word)
  106.                    low for 1 stop bit}
  107.   WLS   =   3;    {Select Number of bits per word as follows:
  108.                     Bit 1            Bit 2     Word Length
  109.                       0                0         5 Bits
  110.                       0                1         6 Bits
  111.                       1                0         7 Bits
  112.                       1                1         8 Bits}
  113.   LOOP  =   16;   {Enable loop back for testing}
  114.   OUT2  =   8;    {Enable interrupt line drivers if high}
  115.   OUT1  =   4;    {Reset Smartmodem 1200B}
  116.   RTS   =   2;    {Request to send follows this bit}
  117.   DTR   =   1;    {Data Terminal Ready follows this bit inversely, required
  118.                    for modem operation}
  119.  
  120. {****************************************************************************}
  121. Function Upper_Left_X : Integer;       {* These four routines allow a       *}
  122. {1*}                                   {* routine to adjust its output      *}
  123. Begin                                  {* according to what size window it  *}
  124.   Upper_Left_X := Mem[Dseg:$156] + 1;  {* is operating in.  They are        *}
  125. End;                                   {* compatible only with Turbo Pascal *}
  126.                                        {* version 2.0 on an IBM PC or       *}
  127. Function Upper_Left_Y : Integer;       {* compatible                        *}
  128. {2*}
  129. Begin
  130.   Upper_Left_Y := Mem[Dseg:$157] + 1;
  131. End;
  132.  
  133. Var
  134. {3*}
  135.   Lower_Right_X : Byte Absolute Cseg:$16A;
  136. {4*}
  137.   Lower_Right_Y : Byte Absolute Cseg:$16B;
  138.  
  139. {****************************************************************************}
  140. Procedure RvsOn;                       {*  These two routines turn on and   *}
  141. {5*}                                   {*  off Reverse video on the IBM PC  *}
  142. Begin                                  {*************************************}
  143.   TextColor(0);
  144.   TextBackGround(7);
  145. End;
  146.  
  147. Procedure RvsOff;
  148. {6*}
  149. Begin
  150.   LowVideo;
  151. End;
  152.  
  153. {30**************************************************************************}
  154. Procedure Inc(                     {* Increment argument by One             *}
  155.           Var I : Integer);        {*****************************************}
  156.  
  157. Begin
  158.   I := I + 1;
  159. End;
  160.  
  161. {31**************************************************************************}
  162. Procedure Dec(                     {* Decrement argument by One             *}
  163.           Var I : Integer);        {*****************************************}
  164.  
  165. Begin
  166.   I := I - 1;
  167. End;
  168.  
  169. {26**************************************************************************}
  170. Procedure Wait;                       {* Wait for a keypress from the KBD   *}
  171.                                       {**************************************}
  172. Var
  173.   AnyKey : Char;
  174.  
  175. Begin
  176.   Read(Kbd,AnyKey);
  177. End;
  178.  
  179. {****************************************************************************}
  180. Type                                   {* Just a couple of type declarations*}
  181.   Menu_Item       = String[40];        {* needed for a number of routines   *}
  182.                                        {*************************************}
  183.   Menu_Selections = Array[1..15] of Menu_Item;
  184.   Long_String     = String[255];
  185.   Register        = Record
  186.                     AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer;
  187.                     End;
  188.   ScreenLoc       = Record
  189.     Ch            : Char;
  190.     Attrib        : Byte;
  191.   End;
  192.   Video           = Array[1..25] of Array[1..80] of ScreenLoc;
  193.   Video_Ptr       = ^Video_Stack;
  194.   vidscr          = array[1..1] of screenloc;
  195.   Video_Stack     = Record
  196.                     Next_Screen  : Video_Ptr;
  197.                     x1,y1,
  198.                     x2,y2        : byte;
  199.                     Screen_store : ^vidscr;
  200.                     End;
  201.  
  202. Var
  203.   ScreenBuffer  : Video;
  204.   Screen_Stack  : Video_Ptr;
  205.   Screen        : ^Video;
  206.   Com           : Integer;
  207.   HelpContext   : Integer;
  208.   ScreenFile    : File of Video;
  209.  
  210. {7***************************************************************************}
  211. Function Yes(Prompt : Long_String) : Boolean;{* This routine prints PROMPT  *}
  212.                                              {* to the screen and waits for *}
  213. Var                                          {* the user to type either a   *}
  214.   Inchar : Char;                             {* 'y' or 'n'.  It is case     *}
  215.                                              {* insensitive.  If a 'y' is   *}
  216. Begin                                        {* entered, the function       *}
  217.   Write(Prompt);                             {* returns TRUE.               *}
  218.   Repeat                                     {*******************************}
  219.     Read(Kbd,Inchar);
  220.   Until Inchar in ['Y','y','N','n'];
  221.   Write(Inchar);
  222.   Yes := Inchar in ['Y','y'];
  223. End;
  224.  
  225. {34**************************************************************************}
  226. Function Upper (S : Long_String)       {* Convert Strng S to Upper case     *}
  227.                : Long_String;          {* Return uppercase string           *}
  228.                                        {*************************************}
  229. Var
  230.   I : Integer;
  231.   lcase : Set of Char;
  232.  
  233. Begin
  234.   lcase := ['a'..'z'];
  235.  
  236.   For I := 1 to Length(S) do
  237.     If S[I] In lcase then
  238.       S[I] := Char(Ord(S[I]) - 32);
  239.   Upper := S;
  240. End;
  241.  
  242. {35**************************************************************************}
  243. Function Lower (S : Long_String)    {* Convert string S to lowercase        *}
  244.                : Long_String;       {* Return lowercase string              *}
  245.                                     {****************************************}
  246. Var
  247.   I : Integer;
  248.   ucase : Set of Char;
  249.  
  250. Begin
  251.   ucase := ['A'..'Z'];
  252.  
  253. For I := 1 to Length(S) do
  254.   If S[I] in ucase then
  255.     S[I] := Char(Ord(S[I]) + 32);
  256. lower := S;
  257. End;
  258.  
  259. {8***************************************************************************}
  260. Procedure Click;                       {* Makes a clicking noise            *
  261.                                         *************************************}
  262. var f,n : integer;
  263.  
  264. Begin
  265.   Sound(2000);
  266.   Delay(5);
  267.   NoSound;
  268. End;
  269.  
  270. {9***************************************************************************}
  271. Procedure Alert(Message : Long_String);{* This routine prints MESSAGE to the*}
  272.                                        {* screen and makes an obnoxious     *}
  273. Var                                    {* noise for about 1 second          *}
  274.   I : Integer;                         {*************************************}
  275.   i1,i2,i3,i4 : integer;
  276.  
  277.  
  278. begin
  279.   write(Message);
  280.   for i4 := 1 to 10 do
  281.     begin
  282.     i2 := 250 + i4 * 25;
  283.     for i3 := 1 to 2 do
  284.       begin
  285.       for i1 := 1 to 30 - i3 * 2 do
  286.         begin
  287.         sound(i1 + i2 + i3 * 2);
  288.         delay(2);
  289.         end;
  290.       delay(5);
  291.       i2 := i2 + 30;
  292.       end;
  293.     nosound;
  294.     end;
  295. end;
  296.  
  297. {21**************************************************************************}
  298. Procedure Clear_Window;          {* Clear the Active window                 *}
  299.                                  {*******************************************}
  300. Var
  301.   I : Integer;
  302.  
  303. Begin
  304. For I := 1 to Lower_Right_Y - Upper_Left_Y + 1 do
  305.   Begin
  306.   GotoXY(1,I);
  307.   ClrEol;
  308.   End;
  309. End;
  310.  
  311. {10**************************************************************************}
  312. Procedure Beep(N : Integer);    {*  This routine sounds a tone of frequency *}
  313.                                 {*  N for approximately 100 ms              *}
  314. Begin                           {********************************************}
  315.   Sound(n);
  316.   Delay(100);
  317.   NoSound;
  318. End;
  319.  
  320. {28**************************************************************************}
  321. Procedure Push_Screen;                {* This routine stores the current    *}
  322.                                       {* screen into a temporary storage    *}
  323.                                       {* area                               *}
  324.                                       {**************************************}
  325. Var
  326.   Temp   : Video_Ptr;
  327.   i,j,k  : integer;
  328.  
  329. Begin
  330.   If (MaxAvail < 0) or (MaxAvail > 4096) then
  331.     Begin
  332.     If Screen = Nil then
  333.       Screen := Ptr($B000,0);
  334.     new(Temp);
  335.     temp^.x1 := 1;
  336.     temp^.y1 := 1;
  337.     temp^.x2 := 80;
  338.     temp^.y2 := 25;
  339.     getmem(temp^.screen_store,4000);
  340.     Temp^.Next_Screen := Screen_Stack;
  341.     k := 1;
  342.     for i := 1 to 25 do
  343.       for j := 1 to 80 do
  344.         begin
  345.         temp^.screen_store^[k] := screen^[i][j];
  346.         inc(k);
  347.         end;
  348.     Screen_Stack := Temp;
  349.     End
  350.   Else
  351.     Begin
  352.     Alert('Insufficient Memory - You are being dumped');
  353.     Halt;
  354.     End;
  355. End;
  356.  
  357. {29**************************************************************************}
  358. Procedure Pop_Screen;                 {* This routine Pops a screen from the*}
  359.                                       {* Screen Stack                       *}
  360.                                       {**************************************}
  361. Var
  362.   Temp   : Video_Ptr;
  363.   i,j,k  : integer;
  364.  
  365. Begin
  366.   If Screen = nil then
  367.     Screen := Ptr($B000,0);
  368.  
  369.   k := 1;
  370.   for i := screen_stack^.y1 to screen_stack^.y2 do
  371.     for j := screen_stack^.x1 to screen_stack^.x2 do
  372.       begin
  373.       screen^[i][j] := screen_stack^.screen_store^[k];
  374.       inc(k);
  375.       end;
  376.  
  377.   Temp := Screen_Stack;
  378.   Screen_Stack := Screen_Stack^.Next_Screen;
  379.   freemem(Temp^.screen_store,
  380.     ((temp^.x2 - temp^.x1 + 1) * (temp^.y2 - temp^.y1 + 1)) * 2);
  381.   dispose(temp);
  382. End;
  383.  
  384. {43**************************************************************************}
  385. Procedure Marquee                    {* Draws a marquee in center screen    *}
  386.                  (Str : Long_String);{* Around the input parameter          *}
  387.                                      {***************************************}
  388.  
  389. Const
  390.   OnChr = #1;
  391.   OffChr = #2;
  392.  
  393. Var
  394.   I,J,K : Integer;
  395.   X,Y   : Integer;
  396.   Astrsk : Array[1..4] of Record
  397.                             X,Y : Integer;
  398.                             OldX,OldY : Integer;
  399.                             XI,YI     : Integer;
  400.                           End;
  401.  
  402. Begin
  403.   Window(1,1,80,25);
  404.   Push_Screen;
  405.   ClrScr;
  406.   X := 40 - Length(Str) Div 2 - 2;
  407.   For I := 10 to 14 do
  408.     Begin
  409.     Screen^[I][X].Ch := OnChr;
  410.     Screen^[I][X].Attrib := 7;
  411.     Screen^[I][X + Length(Str) + 3].Ch := OnChr;
  412.     Screen^[I][X + Length(Str) + 3].Attrib := 7;
  413.     End;
  414.   For I := X to X + Length(Str) + 3 do
  415.     Begin
  416.     Screen^[10][I].Ch := OnChr;
  417.     Screen^[14][I].Ch := OnChr;
  418.     Screen^[10][I].Attrib := 7;
  419.     Screen^[14][I].Attrib := 7;
  420.     End;
  421.   GotoXY(X+2,12);
  422.   HighVideo;
  423.   Write(Str);
  424.   LowVideo;
  425.  
  426.   Astrsk[1].X := 40;
  427.   Astrsk[1].Y := 10;
  428.   Astrsk[1].XI := 1;
  429.   Astrsk[1].YI := 0;
  430.   Astrsk[2].X := X;
  431.   Astrsk[2].Y := 12;
  432.   Astrsk[2].XI := 0;
  433.   Astrsk[2].YI := -1;
  434.   Astrsk[3].X := X + Length(Str) + 3;
  435.   Astrsk[3].Y := 12;
  436.   Astrsk[3].XI := 0;
  437.   Astrsk[3].YI := 1;
  438.   Astrsk[4].X := 40;
  439.   Astrsk[4].Y := 14;
  440.   Astrsk[4].XI := -1;
  441.   Astrsk[4].YI := 0;
  442.   Astrsk[4].OldX := Astrsk[1].X;
  443.   Astrsk[4].OldY := Astrsk[1].Y;
  444.   Astrsk[3].OldX := Astrsk[2].X;
  445.   Astrsk[3].OldY := Astrsk[2].Y;
  446.   Astrsk[2].OldX := Astrsk[3].X;
  447.   Astrsk[2].OldY := Astrsk[3].Y;
  448.   Astrsk[1].OldX := Astrsk[4].X;
  449.   Astrsk[1].OldY := Astrsk[4].Y;
  450.   K := 1;
  451.  
  452.   Repeat
  453.     If K > 4 Then
  454.       K := 1;
  455.  
  456.     J := Astrsk[K].Y;
  457.     I := Astrsk[K].X;
  458.  
  459.     If Screen = Ptr($B800,0) then
  460.       Repeat Until (Port[$3DA] And 1) = 1
  461.     Else
  462.       Repeat Until (Port[$3BA] And 1) = 1;
  463.  
  464.     Screen^[J][I].Ch := OffChr;
  465.     Screen^[Astrsk[K].OldY][Astrsk[K].OldX].Ch := OnChr;
  466.     Screen^[J][I].Attrib := 15;
  467.     Screen^[Astrsk[K].OldY][Astrsk[K].OldX].Attrib := 7;
  468.  
  469.     Astrsk[K].OldX := Astrsk[K].X;
  470.     Astrsk[K].OldY := Astrsk[K].Y;
  471.  
  472.     I := I + Astrsk[K].XI;
  473.     J := J + Astrsk[K].YI;
  474.  
  475.     If I > (X + Length(Str) + 3) then
  476.       Begin
  477.       I := I - Astrsk[K].XI;
  478.       Astrsk[K].XI := 0;
  479.       Astrsk[K].YI := 1;
  480.       End;
  481.  
  482.     If J > 14 then
  483.       Begin
  484.       J := J - Astrsk[K].YI;
  485.       Astrsk[K].YI := 0;
  486.       Astrsk[K].XI := -1;
  487.       End;
  488.     If I < X then
  489.       Begin
  490.       I := I - Astrsk[K].XI;
  491.       Astrsk[K].XI := 0;
  492.       Astrsk[K].YI := -1;
  493.       End;
  494.     If J < 10 then
  495.       Begin
  496.       J := J - Astrsk[K].YI;
  497.       Astrsk[K].YI := 0;
  498.       Astrsk[K].XI := 1;
  499.       End;
  500.  
  501.     Astrsk[K].Y := J;
  502.     Astrsk[K].X := I;
  503.     Inc(K);
  504.  
  505.   Until KeyPressed;
  506.   Wait;
  507.   Pop_Screen;
  508. End;
  509.  
  510. {44**************************************************************************}
  511. Procedure Help;                      {* This routine reads a screen from the*}
  512.                                      {* Screen file and displays it         *}
  513. Begin                                {***************************************}
  514.   Push_Screen;
  515.   {$I-}
  516.   Seek(ScreenFile,HelpContext);
  517.   {$I+}
  518.   If IOResult = 0 Then
  519.     Begin
  520.     {$I-}
  521.     Read(ScreenFile,ScreenBuffer);
  522.     {$I+}
  523.     Screen^ := ScreenBuffer;
  524.     If IOResult <> 0 Then
  525.       Marquee('Sorry, I''m helpless in this situation')
  526.     Else
  527.       Wait;
  528.     End
  529.   Else
  530.     Marquee('Sorry, wish I could help you.');
  531.   Pop_Screen;
  532. End;
  533.  
  534. {11**************************************************************************}
  535. Function Replicate (                          {* Repeat a character         *}
  536.                      Count : Integer;         {* Number of Repititions      *}
  537.                      Ascii : Char             {* Character to be repeated   *}
  538.                     )      : Long_String;     {* String containing repeated *}
  539.                                               {* character                  *
  540.  * This function takes the character in 'Ascii', repeats it 'Count' times   *
  541.  * and returns the resulting string as a 'Long_String'                      *
  542.  ****************************************************************************}
  543.  
  544. Var
  545.   Temp : Long_String;  {Used to hold the incomplete result}
  546.   I    : Byte;         {For Counter}
  547.  
  548. Begin
  549.   Temp := '';
  550.   For I := 1 to Count do
  551.     Temp := Temp + Ascii;
  552.   Replicate := Temp;
  553. End; {Replicate}
  554.  
  555. {12*************************************************************************}
  556. Function Left (                       {* Left Justifies a string in a      *}
  557.                 Str : Long_String;    {* field of spaces                   *}
  558.                 Width : Integer       {*************************************}
  559.               ) : Long_String;
  560.  
  561. Begin
  562.   If Length(Str) > Width then
  563.     Left := Copy(Str,1,Width)
  564.   Else
  565.     Left := Str + Replicate(Width - Length(Str),' ');
  566. End;
  567.  
  568. {13**************************************************************************}
  569. Function Center (                              {* Centers a string in field *}
  570.                   Field_Width   : Byte;        {* Width of field for center *}
  571.                   Center_String : Long_String  {* String to Center          *}
  572.                 )               : Long_String; {* Return the string         *}
  573. {************************************************                           *
  574.  * This functions takes the string 'Center_String' and centers it in a      *
  575.  * field 'Field_Width' Spaces long.  It returns a 'Long_String' with a      *
  576.  * length equal to 'Field_Width'.  If the 'Center_String' is longer than    *
  577.  * field width, it is truncated on the right end and is not centered.       *
  578.  ****************************************************************************}
  579.  
  580. Var
  581.   Temp   : Long_String;
  582.   Middle : Byte;
  583.  
  584. Begin
  585.   Middle := Field_Width div 2;
  586.   If Length(Center_String) > Field_Width then
  587.     Center := Copy(Center_String,1,Field_Width) {Truncate and return}
  588.   Else
  589.     Begin
  590.     Temp := Replicate(Middle - (Length(Center_String) div 2),' ') +
  591.             Center_String +
  592.             Replicate(Middle - (Length(Center_String) div 2) + 1,' ');
  593.     Center := Copy(Temp, 1, Field_Width)  {Truncate to Field_Width Characters}
  594.     End {Else}
  595.  End; {Center}
  596.  
  597. {39*************************************************************************}
  598. Function Power(X : Real; Y : Integer):   {* This function raises X to the  *}
  599.                Real;                     {* Yth power                      *}
  600.                                          {**********************************}
  601. Var
  602.   I : Integer;
  603.   N : Real;
  604.  
  605. Begin
  606.   N := 1.0;
  607.   For I := 1 To Y do
  608.     N := N * X;
  609.   Power := N;
  610. End; {Power}
  611.  
  612. {14*************************************************************************}
  613. Function  Get_Payment_Amount (Loan_Amount :   Real;
  614.                               Interest_Rate : Real;
  615.                               Amort_Over    : Real
  616.                              )              : Real;
  617.  
  618. VAR
  619.  
  620.   Monthly_Interest_Rate   :  Real;
  621.   Number_of_Payments      :  Integer;
  622.  
  623. BEGIN
  624.  
  625.   Monthly_Interest_Rate  :=  (Interest_Rate / 100.0) / 12.0;
  626.   Number_of_Payments  := Trunc (Amort_Over * 12);
  627.   Get_Payment_Amount := Loan_Amount *
  628.     (1 / ((1 - 1 / Power((1 + Monthly_Interest_Rate),Number_Of_Payments))/
  629.     Monthly_Interest_Rate));
  630.  
  631. END;
  632.  
  633. {15**************************************************************************}
  634. Procedure Write_Neatly (                 {* Routine to write numbers        *}
  635.                    var OutFile  : Text;  {* output file                     *}
  636.                        Number   : Real;  {* Number to be written            *}
  637.                        Width    : Byte;  {* Width of write area             *}
  638.                        Max_Dec  : Byte   {* Number of decimal places        *}
  639.                        );                {* This routine takes NUMBER, and  *}
  640.                                          {* formats it with commas and      *}
  641.                                          {* truncates to MAX_DEC decimal    *}
  642.                                          {* places.  If NUMBER is to big to *}
  643.                                          {* fit in WIDTH, then a row of     *}
  644.                                          {* asterisks WIDTH long is output  *}
  645.                                          {***********************************}
  646. Const
  647.   Valid_Digits : Set of char = ['0'..'9','.','-','+','e'];
  648.  
  649. Var
  650.   Field : Long_String;
  651.   Point : Integer;
  652.   I,J   : Integer;       {Spares for counters}
  653.  
  654. Begin
  655.   For I := 1 to Max_Dec do
  656.     Number := Number * 10;
  657.   Number := Number + 0.6;
  658.   For I := 1 to Max_Dec do
  659.     Number := Number / 10;
  660.   Str(Number:0:20,Field);  {Convert the input to a string}
  661.   I := 1;
  662.  
  663.   I := Pos('.',Field);  {Where's the Decimal!}
  664.  
  665.   If I = 0 then
  666.     Begin
  667.     Field := Field + '.';     {If no decimal, then add one}
  668.     Point := Length(Field);
  669.     End
  670.   Else
  671.     Point := I;
  672.  
  673.   I := Point - 3;  {Get the Point?}
  674.  
  675.   While I > 1 do             {put in commas, start at the back and work }
  676.     Begin                    {to the front}
  677.     Insert(',',Field,I);
  678.     I := I - 3
  679.     End;
  680.  
  681.   I := Pos('.',Field) - 1;    {Find that pesky decimal}
  682.   J := 0;
  683.  
  684.   While J <= Max_Dec do
  685.     Begin
  686.     I := I + 1;                  {Pad to Max_Dec with zeros}
  687.     If I >= Length(Field) then
  688.       Field := Field + '0';
  689.     J := J + 1;
  690.     End;
  691.  
  692.   Field := Copy(Field,1,I);      {Clean it up a little and elimate trailers}
  693.  
  694.   If Max_Dec = 0 then
  695.     Field := Copy(Field,1,I - 1); {Truncate to integer if necessary}
  696.  
  697.   If (Length(Field) > Width) and (Width > 0) then
  698.     Write(Replicate(Width,'*'))  {Too Big! tell with asterisks}
  699.   Else
  700.     Write(OutFile,Field:Width);  {all that for this}
  701.  
  702. End;
  703.  
  704. {16**************************************************************************}
  705. Function Get_Str (                          {* Get a string with editing    *}
  706.              Var In_Str      : Long_String; {* String to be edited          *}
  707.                  Buffer_Len  : Integer;     {* Its length                   *}
  708.                  Start_X     : Integer;     {* Column to start in           *}
  709.                  Y           : Integer;     {* Row for input                *}
  710.                  Force_Case  : Boolean      {* Force Input to Upper case    *}
  711.                  )           : Char;        {* Return terminating Character *}
  712.                                             {*                              *}
  713.                                             {* This is a fairly versatile   *}
  714.                                             {* string input and editing     *}
  715.                                             {* routine.  It takes IN_STRING *}
  716.                                             {* displays it at START_X,ROW   *}
  717.                                             {* allows the user to edit the  *}
  718.                                             {* string using WordStar(tm)    *}
  719.                                             {* commands.  It returns the    *}
  720.                                             {* character used to terminate  *}
  721.                                             {* input.  By setting FORCE_CASE*}
  722.                                             {* true, all input is forced to *}
  723.                                             {* upper case                   *}
  724.                                             {********************************}
  725. Const
  726.   KeyClick = True;
  727.  
  728. Var
  729.   Insert_Mode  : Boolean;
  730.   Done         : Boolean;
  731.   Current_Char : Char;
  732.   X            : Byte;
  733.   Escape       : Boolean;
  734.   Current      : Char;
  735.   in_string    : Long_String;
  736.  
  737. Begin
  738.   Done         := False;        { **                              }
  739.   Insert_Mode  := False;        {  * Initialize starting variables}
  740.   GotoXY(Start_X,Y);            {  *                              }
  741.   X := Start_X;                 { **                              }
  742.   Write(Replicate(Buffer_Len,'_'));
  743.   In_String := in_str;
  744.   GotoXY(X,Y);
  745.   Write (In_String);            {Write the initial value of the string}
  746.   GotoXY(X,Y);
  747.  
  748.   Repeat                                 {Start main edit/input loop}
  749.  
  750.     If (X - Start_X) = Buffer_Len then
  751.        Current_Char := ^M                {Terminate input if buffer is full}
  752.     Else
  753.        Read(Kbd,Current_Char);           {Get a character}
  754.  
  755.     If Force_Case then
  756.       Current_Char := UpCase(Current_Char); {force case if necessary}
  757.  
  758.     Repeat
  759.       Escape := False;
  760.       Case Current_Char of        {Act on the current input}
  761.  
  762.         ^[        : If KeyPressed then
  763.                       Begin
  764.                       Read(Kbd,Current_Char);
  765.                       Escape := True;
  766.                       Case Current_Char of           {Translate escape codes to}
  767.                         'H' : Current_Char := ^E;    {WordStar command codes   }
  768.                         'P' : Current_Char := ^X;
  769.                         'K' : Current_Char := ^S;
  770.                         'M' : Current_Char := ^D;
  771.                         'S' : Current_Char := ^G;
  772.                         'R' : Current_Char := ^V;
  773.                         '<' : Current_Char := ^R;
  774.                         's' : Current_Char := ^A;
  775.                         't' : Current_Char := ^F;
  776.                         ';' : Begin
  777.                               Help;
  778.                               Current_Char := ^@;
  779.                               End;
  780.                         'D' : Begin                  {Special Terminator}
  781.                               Done := True;
  782.                               Escape := False;
  783.                               End;
  784.                         'I' : Begin
  785.                               Done := True;
  786.                               Escape := False;
  787.                               End;
  788.                         'Q' : Begin
  789.                               Done := True;
  790.                               Escape := False;
  791.                               End;
  792.                         'O' : Begin
  793.                               Done := True;
  794.                               Escape := False;
  795.                               End;
  796.                         'G' : Begin
  797.                               Done := True;
  798.                               Escape := False;
  799.                               End;
  800.                       End; {Case}
  801.                       End; {^[}
  802.         ^E        : Done := True;                  {**               }
  803.                                                    { ** All finished }
  804.         ^X        : Done := True;                  {**               }
  805.         ^F        : x := start_x + length(in_string);
  806.         ^A        : x := start_x;
  807.         ^R        : Begin
  808.                     In_string := in_str;
  809.                     Gotoxy(start_x,y);
  810.                     write(replicate(Buffer_len,'_'));
  811.                     GotoXY(Start_X,Y);
  812.                     Write(in_string);
  813.                     End;
  814.  
  815.         ^V        : Insert_Mode := Insert_Mode XOR True; {toggle insert}
  816.  
  817.         ^S        : If X > Start_X then    {non destructive backspace}
  818.                        X := X - 1;
  819.  
  820.         ^H,#127   : If X > Start_X then    {destructive backspace}
  821.                        Begin
  822.                        Delete(In_String, X - Start_X, 1);
  823.                        GotoXY(Start_X,Y);
  824.                        Write(In_String + '_');
  825.                        X := X - 1;
  826.                        End;
  827.  
  828.         ^D        : If (X - Start_X) < Buffer_Len then  {forward 1 character}
  829.                       If (X - Start_X) < Length(In_String) Then
  830.                         X := X + 1;
  831.  
  832.         ^G        : Begin
  833.                     Delete(In_String, X - Start_X + 1,1); {delete character}
  834.                     GotoXY(Start_X,Y);                    {under the cursor}
  835.                     Write(In_String + '_');
  836.                     End;
  837.  
  838.         ^M        : Done := True;         {**}
  839.                                           { *** All Done}
  840.         ^J        : Done := True;         {**}
  841.  
  842.         ' '..'~'  : If (X - Start_X) >= Length(In_String) Then
  843.                       Begin
  844.                       In_String := In_String + Current_Char;
  845.                       GotoXY(X,Y);
  846.                       Write(Current_Char);
  847.                       If (X - Start_X) < Buffer_Len then
  848.                         X := X + 1;
  849.                       End
  850.  
  851.                     Else
  852.  
  853.                       If Insert_Mode then   {Just a run of the mill character}
  854.                         Begin               {Insert Mode}
  855.                         Insert(Current_Char,In_String, X - Start_X + 1);
  856.                         In_String := Copy(In_String,1,Buffer_Len);
  857.                         GotoXY(Start_X,Y);
  858.                         Write(In_String);
  859.  
  860.                         If (X - Start_X) < Buffer_Len then
  861.                           X := X + 1;
  862.                         GotoXY(X,Y);
  863.                         End
  864.  
  865.                       Else
  866.  
  867.                         Begin              {OverWrite Mode}
  868.                         In_String[X - Start_X + 1] := Current_Char;
  869.                         GotoXY(X,Y);
  870.                         Write(Current_Char);
  871.                         If (X - Start_X) < Buffer_Len then
  872.                           X := X + 1;
  873.                         End;
  874.  
  875.         Else
  876.       End; {Case}
  877.     Until Not Escape;
  878.     GotoXY(X,Y);
  879.     If KeyClick Then
  880.       Click;
  881.   Until Done;
  882.   Get_Str := Current_Char;               {Return the terminator}
  883.   In_str := In_string;
  884. End;
  885.  
  886. {17**************************************************************************}
  887. Function Get_Num  (                   {* This routine gets number from user *}
  888.               var Value     : Real;   {* Current Value and Returned Value   *}
  889.                   Decimals  : Integer;{* Number of Decimal Places           *}
  890.                   Min_Value : Real;   {* Minimum Value                      *}
  891.                   Max_Value : Real;   {* Maximum Value                      *}
  892.                   X         : Byte;   {* Column                             *}
  893.                   Y         : Byte    {* Row                                *}
  894.                   )         : Char;   {* Terminator                         *}
  895.                                       {*                                    *}
  896.                                       {* This routine does basically the    *}
  897.                                       {* thing as Get_Str only for numbers  *}
  898.                                       {* There are more options however.    *}
  899.                                       {* Basically Min and Max Value allow  *}
  900.                                       {* to specify the range of acceptable *}
  901.                                       {* values and DECIMALS allows you to  *}
  902.                                       {* specify the number of decimal      *}
  903.                                       {* places desired                     *}
  904.                                       {**************************************}
  905.  
  906. Const
  907.   Valid_Digits : Set of char = ['0'..'9','.','-','+','e'];
  908.  
  909. Var
  910.   I1,I2  : Integer;
  911.   S1     : Long_String;
  912.   S2     : Long_String;
  913.   S3     : Long_String;
  914.   Inchar : Char;
  915.  
  916. Begin
  917.   Str(Value:1:Decimals,S1);       {Convert to a string}
  918.   Str(Max_Value:1:Decimals,S3);   {find out how long a string max val is}
  919.  
  920.   Repeat                 {Main Loop}
  921.     S2 := '';
  922.  
  923.     Inchar := Get_Str(S1,Length(S3),X,Y,False); {Get_Str does the }
  924.                                                            {work}
  925.     For I2 := 1 to Length(S1) do     {Strip out non digits}
  926.       If S1[I2] in Valid_Digits then
  927.         S2 := S2 + S1[I2];
  928.  
  929.     Val(S2,Value,I1);                 {Find out its value}
  930.  
  931.   Until (Value >= Min_Value) and (Value <= Max_Value) and (I1 = 0); {do it }
  932.                                                            {until its right}
  933.  
  934.   GotoXY(X,Y);
  935.  
  936.   Write_Neatly(Output,Value,Length(S3),Decimals); {print the result}
  937.  
  938.   Get_Num := Inchar;  {Assign the terminator}
  939.  
  940. end;
  941.  
  942. {18**************************************************************************}
  943. procedure Frame(                      {* Frame the section of screen within *}
  944.                 UpperLeftX,           {* these bounds                       *}
  945.                 UpperLeftY,           {**************************************}
  946.                 LowerRightX,
  947.                 LowerRightY: Integer);
  948.   var
  949.     i: Integer;
  950.  
  951. begin
  952.   GotoXY(UpperLeftX,UpperLeftY);
  953.   Write(Chr(218));
  954.   GotoXY(UpperLeftX,LowerRightY);
  955.   Write(Chr(192));
  956.   GotoXY(LowerRightX,UpperLeftY);
  957.   Write(Chr(191));
  958.   GotoXY(LowerRightX,LowerRightY);
  959.   Write(Chr(217));
  960.   For I := UpperLeftX + 1 to LowerRightX - 1 do
  961.     Begin
  962.     GotoXY(I,UpperLeftY);
  963.     Write(Chr(196));
  964.     GotoXY(I,LowerRightY);
  965.     Write(Chr(196));
  966.     End;
  967.   For I := UpperLeftY + 1 to LowerRightY - 1 do
  968.     Begin
  969.     GotoXY(UpperLeftX,I);
  970.     Write(Chr(179));
  971.     GotoXY(LowerRightX,I);
  972.     Write(Chr(179));
  973.     End;
  974. end;  { Frame }
  975.  
  976. {19***************************************************************************}
  977. procedure UnFrame(                      {* This routine does the opposite of *}
  978.                   UpperLeftX,           {* frame                             *}
  979.                   UpperLeftY,           {*************************************}
  980.                   LowerRightX,
  981.                   LowerRightY: Integer);
  982.  
  983. var
  984.   i: Integer;
  985. begin
  986.   GotoXY(UpperLeftX, UpperLeftY);
  987.   Write(' ');
  988.  
  989.   for i:=UpperLeftX+1 to LowerRightX-1 do
  990.     Write(' ');
  991.  
  992.   Write(' ');
  993.  
  994.   for i:=UpperLeftY+1 to LowerRightY-1 do
  995.     begin
  996.     GotoXY(UpperLeftX , i);
  997.     Write(' ');
  998.     GotoXY(LowerRightX, i);
  999.     Write(' ');
  1000.     end;
  1001.  
  1002.     GotoXY(UpperLeftX, LowerRightY);
  1003.     Write(' ');
  1004.  
  1005.     for i:=UpperLeftX+1 to LowerRightX-1 do
  1006.       Write(' ');
  1007.  
  1008.     Write(' ');
  1009. end;  {UnFrame }
  1010.  
  1011. {****************************************************************************}
  1012. Function Menu (                               {* Display a Menu             *}
  1013.                 Item_List  : Menu_Selections; {* List of Options on Menu    *}
  1014.                                               {* Last Item must be Null     *}
  1015.                                               {* String for proper operation*}
  1016.                                               {* No more than 14 items per  *}
  1017.                 Menu_X     : Integer;         {* X Location of Menu         *}
  1018.                                               {* If Menu_X = 0 then the     *}
  1019.                                               {* Menu is centered on the    *}
  1020.                                               {* Screen                     *}
  1021.                 Menu_Y     : Integer;         {* Y Location of Menu         *}
  1022.                 Menu_Title : Menu_Item;       {* Title of Menu              *}
  1023.                 Title_X    : Integer;         {* X Location of Title        *}
  1024.                                               {* If Title_X = 0 then the    *}
  1025.                                               {* Title is centered on the   *}
  1026.                                               {* screen                     *}
  1027.                 Title_Y    : Integer;         {* Y Location of Title        *}
  1028.                 Default    : Integer          {* Default Selection          *}
  1029.               )            : Integer;         {* Return the index of the    *}
  1030.                                               {* item selected by the user  *}
  1031.                                               {*                            *}
  1032. {***********************************************                            *
  1033. * This Routine Displays a Menu on the screen at the location specified by   *
  1034. * Menu_X and Menu_Y.  The Menu Title is displayed in Reverse Video at the   *
  1035. * Location specified by Title_X and Title_Y.  The User selects an item from *
  1036. * the menu by using <CTRL>-E to move a reverse video cursor bar up and      *
  1037. * <CTRL>-X to move it down.  After the cursor is on the item desired by the *
  1038. * user, he must press return.  At this point the routine returns the item   *
  1039. * number of the selection.                                                  *
  1040. *****************************************************************************}
  1041.  
  1042. Const
  1043.   CR = #13;
  1044.   Up = #5;
  1045.   Dn = #24;
  1046.  
  1047. Var
  1048.   Inchar : char;
  1049.   Menu_Pointer : 1..15;
  1050.   Menu_Length : 1..15;
  1051.   Last : Integer;
  1052.   Width : Integer;
  1053.   Len   : Integer;
  1054.   X1,X2,Y1,Y2 : Integer;
  1055.   I,j,k   : integer;
  1056.   instr : long_string;
  1057.  
  1058. Begin {Menu}
  1059.  
  1060.   instr := '';
  1061.  
  1062.   Width := Lower_Right_X - Upper_Left_X + 1;   {Calculate Window Size}
  1063.   Len   := Lower_Right_Y - Upper_Left_Y + 1;
  1064.  
  1065.   If Title_X <> 0 then       {position for the title}
  1066.     GotoXY(Title_X,Title_Y)
  1067.   Else
  1068.     GotoXY(1,Title_Y);
  1069.  
  1070.   RvsOn;
  1071.  
  1072.   If Title_X = 0 Then                 {Write the title}
  1073.     Write (Center(Width,Menu_Title))
  1074.   Else
  1075.     Write(Menu_Title);
  1076.  
  1077.   RvsOff;
  1078.  
  1079.   If Width > 38 then        {If there is enough room, write out instructions}
  1080.     Begin                   {otherwise, they is out a luck}
  1081.     Frame(1,Len-3,Width-1,Len);
  1082.     GotoXY((Width div 2) - 6,Len-3);
  1083.     Write(#17);
  1084.     RvsOn;
  1085.     Write('Instructions');
  1086.     RvsOff;
  1087.     Write(#16);
  1088.     TextColor(15);
  1089.     GotoXY(2,Len-2);
  1090.     Write(Center(Width-3,'Use '+#24+' and '+#25+' to Highlight a Selection'));
  1091.     GotoXY(2,Len-1);
  1092.     Write(Center(Width-3,' And '+#17+'DY to make the Selection'));
  1093.     TextColor(7);
  1094.     End;
  1095.  
  1096.   Inchar := ' ';               {Initialize variables}
  1097.   Menu_Pointer := 1;
  1098.  
  1099.   {Display the actual menu selections and determine how many selections
  1100.    are available}
  1101.  
  1102.   While (Menu_pointer <=15) and (length(Item_list[Menu_pointer]) > 0) do
  1103.  
  1104.     Begin
  1105.     If Menu_X <> 0 then
  1106.       Begin
  1107.       GotoXY(Menu_X,Menu_Y - 1 + Menu_Pointer);
  1108.       Write(Item_List[Menu_Pointer])
  1109.       End {If}
  1110.     Else
  1111.       Begin
  1112.       GotoXY(1,Menu_Y - 1 + Menu_Pointer);
  1113.       Write(Center(Width-1,Item_List[Menu_Pointer]))
  1114.       End; {Else}
  1115.     Menu_Pointer := Menu_Pointer + 1;
  1116.     End;  {While}
  1117.  
  1118.   Menu_Length := Menu_Pointer - 1;
  1119.   Menu_Pointer := Default;
  1120.  
  1121.   While inchar <> CR do          {Main loop}
  1122.  
  1123.     Begin
  1124.     If Menu_X <> 0 then
  1125.       Begin
  1126.       GotoXY(Menu_X,Menu_Pointer - 1 + Menu_Y); {Highlight the current menu}
  1127.       RvsOn;                                    {item}
  1128.       Write(Item_List[Menu_Pointer]);
  1129.       RvsOff;
  1130.       End {If}
  1131.     Else
  1132.       Begin
  1133.       GotoXY(1,Menu_Pointer - 1 + Menu_Y);
  1134.       RvsOn;
  1135.       Write(Center(Width-1,Item_List[Menu_Pointer]));
  1136.       RvsOff;
  1137.       End; {Else}
  1138.  
  1139.     Read(Kbd,Inchar);    {get a character from the user}
  1140.     Click;
  1141.  
  1142.     Last := Menu_Pointer;
  1143.  
  1144.     If Not (Inchar in [^[,Up,Dn,Cr]) then
  1145.  
  1146.       Begin
  1147.  
  1148.       if inchar = #127 then
  1149.         instr := ''
  1150.       else
  1151.  
  1152.         if inchar = ^H then
  1153.           delete(instr,length(instr),1)
  1154.         else
  1155.           instr := instr + inchar;
  1156.  
  1157.       j := 0;
  1158.       k := 0;
  1159.  
  1160.       for i := 1 to Menu_Length do
  1161.  
  1162.         if lower(instr) = lower(copy(item_list[i],1,length(instr))) then
  1163.  
  1164.           begin
  1165.           inc(j);
  1166.  
  1167.           if k = 0 then
  1168.             k := i;
  1169.  
  1170.           end;
  1171.  
  1172.       if k <> 0 then
  1173.         menu_pointer := k;
  1174.  
  1175.       if (j = 1) or (j = 0) then
  1176.         instr := '';
  1177.  
  1178.       end;
  1179.  
  1180.     If (Inchar = ^[) and KeyPressed then   {get the escape code}
  1181.       Read(Kbd, Inchar);
  1182.  
  1183.     If Inchar = ';' Then
  1184.       Begin
  1185.       X1 := Upper_Left_X;
  1186.       Y1 := Upper_Left_Y;
  1187.       X2 := Lower_Right_X;
  1188.       Y2 := Lower_Right_Y;
  1189.       Help;
  1190.       Window(X1,Y1,X2,Y2);
  1191.       End;
  1192.  
  1193.     If (Inchar = Up) Or (Inchar = 'H') then
  1194.       Begin                                    {They hit up arrow}
  1195.       Menu_Pointer := Menu_Pointer - 1;
  1196.       If Menu_Pointer < 1 then
  1197.         Menu_Pointer := Menu_Length;
  1198.       instr := '';
  1199.       End;  {If}
  1200.  
  1201.     If (Inchar = Dn) Or (Inchar = 'P') then
  1202.       Begin                                    {They hit down arrow}
  1203.       Menu_Pointer := Menu_Pointer + 1;
  1204.       if Menu_Pointer > Menu_Length then
  1205.         Menu_Pointer := 1;
  1206.       instr := '';
  1207.       end;  {If}
  1208.  
  1209.     If Menu_X <> 0 then                        {UnHighlight the old selection}
  1210.       Begin
  1211.       GotoXY(Menu_X, Last - 1 + Menu_Y);
  1212.       Write(Item_List[Last]);
  1213.       End {If}
  1214.     Else
  1215.       Begin
  1216.       GotoXY(1, Last - 1 + Menu_Y);
  1217.       Write(Center(Width-1,Item_List[Last]));
  1218.       End; {Else}
  1219.  
  1220.     End; {While}
  1221.  
  1222.   Beep(440);                                {They made a selection, beep once}
  1223.   Menu := Menu_Pointer;                     {to confirm}
  1224.  
  1225. end; {Menu}
  1226.  
  1227. {22**************************************************************************}
  1228. Procedure Window_Frame(x1,y1,             {* Create, frame and title a      *}
  1229.                        x2,y2 : Integer;   {* window                         *}
  1230.                        Title : Menu_Item);{**********************************}
  1231.  
  1232. Var
  1233.   Center : Integer;
  1234.  
  1235. Begin
  1236.   Window(1,1,80,25);
  1237.   Frame(x1 - 1, y1 - 1,
  1238.         x2 + 1, y2 + 1);
  1239.   Center := ((x2 - x1) div 2) + x1;
  1240.   GotoXY(Center - (Length(Title) div 2)-1,y1-1);
  1241.   Write(#17);
  1242.   RvsOn;
  1243.   Write(Title);
  1244.   RvsOff;
  1245.   Write(#16);
  1246.   Window(x1,y1,x2,y2);
  1247.   Clear_Window;
  1248. End;
  1249.  
  1250. {23**************************************************************************}
  1251. Function Encrypt(Password : Long_String) {* Encrypt a string using the      *}
  1252.                 : Long_String;           {* following algorithm:            *}
  1253.                                          {*  XOR the ordinal value of each  *}
  1254.   Var                                    {* character in the string with    *}
  1255.     Temp : Long_String;                  {* that of the next character in   *}
  1256.     I : Integer;                         {* the string.  Multiply by 2 the  *}
  1257.                                          {* result and convert back to char *}
  1258.   Begin                                  {* leave the last character of the *}
  1259.     temp := '';                          {* string in plain text as the key *}
  1260.     For I := 1 to Length(Password) - 1 do{***********************************}
  1261.       temp := Temp + Chr((ord(password[i]) xor ord(password[i+1])) shl 2);
  1262.     Encrypt := Temp + Password[Length(Password)];
  1263.   End;
  1264.  
  1265. {24**************************************************************************}
  1266. Function Decrypt(Temp : Long_String)     {* Decrypt a string encrypted by   *}
  1267.                 : Long_String;           {* the preceding procedure         *}
  1268.                                          {***********************************}
  1269.   Var
  1270.     Password : Long_String;
  1271.     I : Integer;
  1272.  
  1273.   Begin
  1274.     Password := Replicate(Length(temp),' ');
  1275.     Password[Length(temp)] := Temp[Length(temp)];
  1276.     For I := Length(Temp) - 1 downto 1 do
  1277.       Password[I] := Chr((ord(temp[i]) shr 2) xor ord(password[i+1]));
  1278.     Decrypt := Password;
  1279.   End;
  1280.  
  1281. {25**************************************************************************}
  1282. Function GetChar(Var Done : Boolean) : Char;{* Get a character from the Kbd *}
  1283.                                             {********************************}
  1284. Var
  1285.   Inchar : Char;
  1286.  
  1287. Begin
  1288.   Read(Kbd,Inchar);
  1289.   Done := (Inchar = ^\);
  1290.   GetChar := Inchar;
  1291. End;
  1292.  
  1293. {27**************************************************************************}
  1294. Function Get_Pass(X,Y : Integer) : Long_String;{* This routine obtains a    *}
  1295.                                                {* password from the user    *}
  1296. Var                                            {* nothing more, nothing less*}
  1297.   Inchar : Char;                               {*****************************}
  1298.   Temp   : Long_String;
  1299.  
  1300. Begin
  1301.   GotoXY(X,Y);
  1302.   Write('Password: ');
  1303.   Temp := '';
  1304.   TextColor(0);
  1305.   TextBackGround(0);
  1306.   Inchar := Get_Str(Temp,10,X + 10,y,True);
  1307.   RvsOff;
  1308.   If Temp = Replicate(10,' ') then
  1309.     Temp := '';
  1310.   Get_Pass := Temp;
  1311. End;
  1312.  
  1313. {32**************************************************************************}
  1314. Procedure SetUp  {Set the UART for communications}
  1315.                (Portal : Integer;
  1316.                 Baud   : Integer;
  1317.                 Parity : Parity_Types;
  1318.                 Stop   : Byte;
  1319.                 Word   : Byte);
  1320.  
  1321. Begin
  1322.  
  1323.   Port[LCR + Portal] := 128;
  1324.  
  1325.   {Set Baud Rate}
  1326.   Baud := Trunc(115200.0 / Baud);
  1327.   Port[DLL + Portal] := Lo(Baud);
  1328.   Port[DLM + Portal] := Hi(Baud);
  1329.  
  1330.   {Set Parity}
  1331.   Case Parity of
  1332.     No_Parity   : Port[LCR + Portal] := Port[LCR + Portal] And Not(PEN);
  1333.     Even_Parity : Begin
  1334.                   Port[LCR + Portal] := Port[LCR + Portal] Or PEN;
  1335.                   Port[LCR + Portal] := Port[LCR + Portal] Or EPS;
  1336.                   Port[LCR + Portal] := Port[LCR + Portal] And Not(STPTY);
  1337.                   End;
  1338.     Odd_Parity  : Begin
  1339.                   Port[LCR + Portal] := Port[LCR + Portal] Or PEN;
  1340.                   Port[LCR + Portal] := Port[LCR + Portal] And Not(EPS);
  1341.                   Port[LCR + Portal] := Port[LCR + Portal] And Not(STPTY);
  1342.                   End;
  1343.   End;
  1344.  
  1345.   {Set Stop Bits}
  1346.   Port[LCR + Portal] := Port[LCR + Portal] And (Not(STB) + (STB * (Stop - 1)));
  1347.  
  1348.   {Set Word Length}
  1349.   Port[LCR + Portal] := Port[LCR + Portal] And Not(WLS);
  1350.   Word := (Word - 5) and WLS;
  1351.   Port[LCR + Portal] := Port[LCR + Portal] or Word;
  1352.  
  1353.   Port[LCR + Portal] := Port[LCR + Portal] And 127;
  1354.  
  1355. End; {Set up}
  1356.  
  1357. {36**************************************************************************}
  1358. Procedure DosConOut(Ch : Char);      {* Write character to video display    *}
  1359.                                      {* using DOS driver                    *}
  1360. Var                                  {***************************************}
  1361.   Registers : Reg;
  1362.  
  1363. Begin
  1364.   Registers.AX := $0200;
  1365.   Registers.DX := Ord(Ch);
  1366.   MsDos(Registers);
  1367. End;
  1368.  
  1369. var
  1370.   serial_buffer : long_string;
  1371.  
  1372. {37**************************************************************************}
  1373. Procedure SerialOut(Ch : Char);      {* This routine sends a character over *}
  1374.                                      {* the rs232 using a standard BIOS call*}
  1375. Var                                  {* (INT 14)                            *}
  1376.   Registers : Reg;                   {***************************************}
  1377.  
  1378. Begin
  1379.   Registers.AX := $0100 + Ord(Ch);    {Set the registers}
  1380.   Registers.DX := Com;
  1381.   Intr($14,Registers);               {Send out the character}
  1382. End;
  1383.  
  1384. {40**************************************************************************}
  1385. Function Data : Boolean;             {* This routine returns true if the    *}
  1386.                                      {* serial port has valid data          *}
  1387. Var                                  {***************************************}
  1388.   Registers : Reg;
  1389.   portno    : integer;
  1390.  
  1391. Begin
  1392.   portno := $3fd - ($100 * Com);
  1393.   data := (port[portno] and 1) = 1;
  1394. End;
  1395.  
  1396. {38**************************************************************************}
  1397. Function SerialIn : Char;            {* This routine reads a character from *}
  1398.                                      {* the serial port if one is available *}
  1399. Var                                  {* If no character is available, the   *}
  1400.   Registers : Reg;                   {* returns a null char (^@).           *}
  1401.   ch        : char;                  {***************************************}
  1402.  
  1403. Begin
  1404.   serialin := chr(port[$3f8 - ($100 * com)]);
  1405. End;
  1406.  
  1407. {41**************************************************************************}
  1408. Procedure ColScr;                    {* Switch to Color Monitor if it is    *}
  1409.                                      {* available, otherwise leave as is    *}
  1410. Const                                {***************************************}
  1411.   VidReg : Array[0..15] of Integer =
  1412.   ($71,$50,$5A,$0A,$1F,$06,$19,$1C,$02,$07,$06,$07,$00,$00,$00,$00);
  1413.   Mode     = $3B8;
  1414.   Color    = $3B9;
  1415.   RegNum   = $3D4;
  1416.   RegVal   = $3D5;
  1417.   ColorVal = $30;
  1418.   ModeVal  = $2D;
  1419.  
  1420. Var
  1421.   I : Byte;
  1422.  
  1423. Begin
  1424. {  Port[Mode] := ModeVal;
  1425.   Port[Color] := ColorVal;
  1426.   For I := 0 to 15 do
  1427.     Begin
  1428.     Port[RegNum] := I;
  1429.     Port[RegVal] := VidReg[I];
  1430.     End;
  1431. }  Screen := Ptr($B800,0);
  1432. End;
  1433.  
  1434. {42**************************************************************************}
  1435. Procedure MonoScr;                   {* Switch to MonoChrome Monitor if     *}
  1436.                                      {* available, otherwise leave as is    *}
  1437. Const                                {***************************************}
  1438.   VidReg : Array[0..15] of Integer =
  1439.   ($61,$50,$52,$0F,$19,$06,$19,$19,$02,$0D,$0B,$0C,$00,$00,$00,$00);
  1440.  
  1441.   Mode     = $3B8;
  1442.   Color    = $3B9;
  1443.   RegNum   = $3B4;
  1444.   RegVal   = $3B5;
  1445.   ColorVal = $30;
  1446.   ModeVal  = $29;
  1447.  
  1448. Var
  1449.   I : Byte;
  1450.  
  1451. Begin
  1452.   Port[Mode] := ModeVal;
  1453.   Port[Color] := ColorVal;
  1454.   For I := 0 to 15 do
  1455.     Begin
  1456.     Port[RegNum] := I;
  1457.     Port[RegVal] := VidReg[I];
  1458.     End;
  1459.   Screen := Ptr($B000,0);
  1460. End;
  1461.  
  1462. {45**************************************************************************}
  1463. Procedure Well;
  1464.  
  1465. Var
  1466.   I,J : Integer;
  1467.  
  1468. Begin
  1469.   I := 0;
  1470.   While Not KeyPressed do
  1471.     Begin
  1472.     Click;
  1473.     Delay(250);
  1474.     If I = 100 then Write('Well?');
  1475.     Inc(I);
  1476.     End;
  1477. End;
  1478.  
  1479. {47**************************************************************************}
  1480. Procedure Siren;                     {* This is the alarm for intruder alert*}
  1481.                                      {***************************************}
  1482. var i,j : integer;
  1483.  
  1484. begin
  1485.   for j := 1 to 20 do
  1486.     begin
  1487.     for i := 200 to 2300 do
  1488.       sound(i);
  1489.     nosound;
  1490.     delay(100);
  1491.     end;
  1492. end;
  1493.  
  1494. {48**************************************************************************}
  1495. type
  1496.   typelist = (ustr,lstr,ulstr,rnum,inum,yn);
  1497.  
  1498. function getform(   var value;
  1499.                         vtype   : typelist;
  1500.                         X,Y,
  1501.                         dp,Len  : integer;
  1502.                         Lstrg   : long_string;
  1503.                         lx,ly   : integer
  1504.                               ) : char;
  1505.  
  1506. var
  1507.   realval : real absolute value;
  1508.   intval  : integer absolute value;
  1509.   strval  : long_string absolute value;
  1510.   boolval : boolean absolute value;
  1511.   mval    : real;
  1512.   tint    : integer;
  1513.   tstr    : long_string;
  1514.   tchar   : char;
  1515.  
  1516. begin
  1517.   gotoxy(lx,ly);
  1518.   highvideo;
  1519.   write(lstrg);
  1520.   case vtype of
  1521.  
  1522.     ustr  : getform := get_str(strval,len,x,y,true);
  1523.     lstr  : begin
  1524.             getform := get_str(strval,len,x,y,false);
  1525.             strval := lower(strval);
  1526.             end;
  1527.     ulstr : getform := get_str(strval,len,x,y,false);
  1528.     rnum  : begin
  1529.             val(replicate(len - dp - 1,'9'),mval,tint);
  1530.             getform := get_num(realval,dp,0,mval,x,y);
  1531.             end;
  1532.     inum  : begin
  1533.             getform := get_num(mval,0,-32767,maxint,x,y);
  1534.             intval := trunc(mval);
  1535.             end;
  1536.     yn    : begin
  1537.             gotoxy(x,y);
  1538.             if boolval then
  1539.               tstr := 'Y'
  1540.             else
  1541.               tstr := 'N';
  1542.             repeat
  1543.               tchar := get_str(tstr,1,x,y,true);
  1544.             until tstr[1] in ['Y','N'];
  1545.             boolval := tstr = 'Y';
  1546.             getform := tchar;
  1547.             end;
  1548.   end;
  1549.  
  1550.   gotoxy(lx,ly);
  1551.   lowvideo;
  1552.   write(lstrg);
  1553. end;
  1554.  
  1555. {*********************************************************************}
  1556.  
  1557. const monthmask = $000F;
  1558.       daymask = $001F;
  1559.       minutemask = $003F;
  1560.       secondmask = $001F;
  1561. type  dtstr = string[8];
  1562.  
  1563. {49*******************************************************************}
  1564.  
  1565. function getdate : dtstr;
  1566.  
  1567. var
  1568.   allregs : register;
  1569.   month, day,
  1570.   year    : string[2];
  1571.   i       : integer;
  1572.   tstr    : dtstr;
  1573.  
  1574. begin
  1575.    allregs.ax := $2A * 256;
  1576.    MsDos(allregs);
  1577.    str((allregs.dx div 256):2,month);
  1578.    str((allregs.dx mod 256):2,day);
  1579.    str((allregs.cx - 1900):2,year);
  1580.    tstr := month + '/' + day + '/' + year;
  1581.    for i := 1 to 8 do
  1582.      if tstr[i] = ' ' then
  1583.        tstr[i] := '0';
  1584.    getdate := tstr;
  1585. end;  {getdate}
  1586.  
  1587. {50*******************************************************************}
  1588.  
  1589. function gettime : dtstr;
  1590.  
  1591. var
  1592.  allregs : register;
  1593.  hour, minute,
  1594.  second  : string[2];
  1595.  i       : integer;
  1596.  tstr    : dtstr;
  1597.  
  1598. begin
  1599.    allregs.ax := $2C * 256;
  1600.    MsDos(allregs);
  1601.    str((allregs.cx div 256):2,hour);
  1602.    str((allregs.cx mod 256):2,minute);
  1603.    str((allregs.dx div 256):2,second);
  1604.    tstr := hour + ':' + minute + ':' + second;
  1605.    for i := 1 to 8 do
  1606.      if tstr[i] = ' ' then
  1607.        tstr[i] := '0';
  1608.    gettime := tstr;
  1609. end;  {gettime}
  1610.  
  1611. {51*******************************************************************}
  1612. procedure push_window(x1,y1,x2,y2 : integer);
  1613.  
  1614. var
  1615.   temp : video_ptr;
  1616.   i,j,k  : integer;
  1617.  
  1618. begin
  1619.   if screen = nil then
  1620.     screen := ptr($b000,0);
  1621.   new(Temp);
  1622.   temp^.x1 := x1;
  1623.   temp^.y1 := y1;
  1624.   temp^.x2 := x2;
  1625.   temp^.y2 := y2;
  1626.   getmem(temp^.screen_store,((x2 - x1 + 1) * (y2 - y1 + 1)) * 2);
  1627.   Temp^.Next_Screen := Screen_Stack;
  1628.   k := 1;
  1629.   for i := y1 to y2 do
  1630.     for j := x1 to x2 do
  1631.       begin
  1632.       temp^.screen_store^[k] := screen^[i][j];
  1633.       inc(k);
  1634.       end;
  1635.   Screen_Stack := Temp;
  1636. end;
  1637.  
  1638. {52*******************************}
  1639. function elapsed_time(start_time : real) : real;
  1640.  
  1641. var
  1642.   j       : integer;
  1643.   i,k,
  1644.   endtime : real;
  1645.  
  1646. begin
  1647.   val(copy(gettime,7,2),i,j);
  1648.   endtime := i * 3600.0;
  1649.   val(copy(gettime,5,2),i,j);
  1650.   endtime := endtime + (i * 60);
  1651.   val(copy(gettime,1,2),i,j);
  1652.   endtime := endtime + i;
  1653.   k := endtime - start_time;
  1654.   elapsed_time := k
  1655. end;
  1656.  
  1657. begin
  1658. end.